home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / nrpas13.zip / MEMCOF.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-29  |  1KB  |  49 lines
  1. PROCEDURE memcof(data: glnarray; n,m: integer; VAR pm: real;
  2.       VAR cof: glmarray; wk1,wk2: glnarray; wkm: glmarray);
  3. (* Programs using routine MEMCOF must define the data types
  4. TYPE
  5.    glnarray = ARRAY [1..n] OF real;
  6.    glmarray = ARRAY [1..m] OF real;
  7. and must provide workspace arrays wk1,wk2,wkm with the dimensions
  8. shown in the arguments above. *)
  9. LABEL 99;
  10. VAR
  11.    k,j,i: integer;
  12.    pneum,p,denom: real;
  13. BEGIN
  14.    p := 0.0;
  15.    FOR j := 1 TO n DO BEGIN
  16.       p := p+sqr(data[j])
  17.    END;
  18.    pm := p/n;
  19.    wk1[1] := data[1];
  20.    wk2[n-1] := data[n];
  21.    FOR j := 2 TO n-1 DO BEGIN
  22.       wk1[j] := data[j];
  23.       wk2[j-1] := data[j]
  24.    END;
  25.    FOR k := 1 TO m DO BEGIN
  26.       pneum := 0.0;
  27.       denom := 0.0;
  28.       FOR j := 1 TO n-k DO BEGIN
  29.          pneum := pneum+wk1[j]*wk2[j];
  30.          denom := denom+sqr(wk1[j])+sqr(wk2[j])
  31.       END;
  32.       cof[k] := 2.0*pneum/denom;
  33.       pm := pm*(1.0-sqr(cof[k]));
  34.       IF (k <> 1) THEN BEGIN
  35.          FOR i := 1 TO k-1 DO BEGIN
  36.             cof[i] := wkm[i]-cof[k]*wkm[k-i]
  37.          END
  38.       END;
  39.       IF (k = m) THEN GOTO 99;
  40.       FOR i := 1 TO k DO BEGIN
  41.          wkm[i] := cof[i]
  42.       END;
  43.       FOR j := 1 TO n-k-1 DO BEGIN
  44.          wk1[j] := wk1[j]-wkm[k]*wk2[j];
  45.          wk2[j] := wk2[j+1]-wkm[k]*wk1[j+1]
  46.       END
  47.    END;
  48. 99:   END;
  49.